home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Dylan Related / Mindy / Mindy 1.2 - portable sources / demos / html2txt / html2txt.dylan next >
Encoding:
Text File  |  1995-03-15  |  31.4 KB  |  827 lines  |  [TEXT/ttxt]
  1. module:        HTML
  2. Author:        Robert Stockton (rgs@cs.cmu.edu)
  3. synopsis:    Converts a file in WWW "HyperText Markup Language" into
  4.                 formatted text.  Provides a small demo of a 'complete
  5.         application' in Dylan.
  6.  
  7. //======================================================================
  8. //
  9. // Copyright (c) 1994  Carnegie Mellon University
  10. // All rights reserved.
  11. // 
  12. // Use and copying of this software and preparation of derivative
  13. // works based on this software are permitted, including commercial
  14. // use, provided that the following conditions are observed:
  15. // 
  16. // 1. This copyright notice must be retained in full on any copies
  17. //    and on appropriate parts of any derivative works.
  18. // 2. Documentation (paper or online) accompanying any system that
  19. //    incorporates this software, or any part of it, must acknowledge
  20. //    the contribution of the Gwydion Project at Carnegie Mellon
  21. //    University.
  22. // 
  23. // This software is made available "as is".  Neither the authors nor
  24. // Carnegie Mellon University make any warranty about the software,
  25. // its performance, or its conformity to any specification.
  26. // 
  27. // Bug reports, questions, comments, and suggestions should be sent by
  28. // E-mail to the Internet address "gwydion-bugs@cs.cmu.edu".
  29. //
  30. //======================================================================
  31.  
  32. //======================================================================
  33. // This program is a filter which converts text in WWWs "HyperText Markup
  34. // Language" into simple formatted text.  Although it is a complete and useful
  35. // application, it is included in this distribution primarily as a
  36. // demonstration of a "real" (albeit small) Dylan (tm) program.
  37. //
  38. // Usage is typical for a UNIX (tm) program.  It may be invoked either with a
  39. // set of files on the command line:
  40. //   mindy -f html2txt.dbc file1.html file2.html ....
  41. // or with no arguments, in which case it reads from "standard input".  At
  42. // present, it accepts no command line switches, although the behavior may be
  43. // changed by changing several constant declarations towards the top of this
  44. // source file.
  45. //
  46. // On most unix systems you should be able to make it into an executable
  47. // script by prepending the the line
  48. //   #!BINDIR/mindy -f
  49. // to the compiled "dbc" file.  You must, of course, remember to specify the
  50. // MINDYPATH environment variable so that it points to the libraries "dylan",
  51. // "streams", "collection-extensions", and "string-extensions".
  52. //
  53. // The basic translation strategy used by html2txt is to scan the file line by
  54. // line, looking for HTML "tags" and accumulating text that lies between any
  55. // two tags.  For each tag type, there is a set of routines (stored in tables)
  56. // which define the appropriate actions for starting and ending the
  57. // "environment" defined by the tag and for dumping the collected text from
  58. // within that environment as formatted text.  A basic control loop in
  59. // "process-HTML" is responsible for calling the appropriate tag actions.
  60. // This routine may be called recusively by some of the tag actions.
  61. //
  62. // The "interface" between adjacent environments is handled via the "blank"
  63. // parameter which is passed around extensively.  This variable states whether
  64. // a blank line has just been printed.  Thus environments which believe that
  65. // they must be preceded or followed by a blank line can determine whetehr
  66. // they must do anything about it, and we lessen the risk that multiple
  67. // routines will emit blank lines when we only want a maximum of one.
  68. //
  69. // The primary advantage of this organization is that it allows the
  70. // specialized actions for a single tag to be grouped together, and allows new
  71. // tags to be cleanly added.  It benefits greatly from Dylan's ability to
  72. // create anonymous methods and manipulate them as first class data objects,
  73. // as well as from the rich set of available collection types.
  74. //======================================================================
  75.  
  76. // Because the entire application is contained in a single file, it is easiest
  77. // to define its library and module "inline".  This capability may not be
  78. // supported by all Dylan implementations, since the "file exchange format" is
  79. // not terribly well defined at present.
  80. define library html
  81.   use dylan;
  82.   use streams;
  83.   use collection-extensions;
  84.   use string-extensions;
  85. end library html;
  86.  
  87. define module html
  88.   use dylan;
  89.   
  90.   // A few basic definitions not present in the Dylan spec
  91.   use extensions, import: {<boolean>, main};
  92.   
  93.   // Additional collection classes and operations from "collection-extensions"
  94.   use subseq;
  95.   use self-organizing-list;
  96.  
  97.   // From string-extensions:
  98.   use substring-search;
  99.   
  100.   // I/O support from the "streams" library
  101.   use streams;
  102.   use standard-io;
  103.   
  104.   export html2text;
  105. end module html;
  106.  
  107. // Basic constants
  108. define constant <strings> = <stretchy-vector>;
  109. define variable *linelen* :: <integer> = 78;
  110. define variable *margin* :: <integer> = 2;
  111.  
  112. define variable *H1cap* :: <boolean> = #t;
  113. define variable *H1under* :: <boolean> = #t;
  114. define variable *H2cap* :: <boolean> = #t;
  115. define variable *H2under* :: <boolean> = #t;
  116. define variable *Bcap* :: <boolean> = #t;
  117. define variable *Icap* :: <boolean> = #t;
  118.  
  119. // Internal constants
  120. define variable Pre-Count :: <integer> = 0;
  121. define variable prefix :: <string> = "";
  122. define variable counter :: <integer> = 0;
  123.  
  124. // We can use hash tables for looking up tag processing routines, but "self
  125. // organizing lists" tend to provide better performance in this case.  Since
  126. // they are completely interchangeable, you can try switching the definition
  127. // here to swap in the "standard" table support instead.
  128.  
  129. define constant <tag-table> = <self-organizing-list>;
  130. // define constant <tag-table> = <object-table>;
  131.  
  132.  
  133. //////////////////////////////////////////////////////////////////////////
  134. //                   String Utilities                //
  135. //////////////////////////////////////////////////////////////////////////
  136.  
  137. // Find the index of first element (after "from") of a sequence which
  138. // satisfies the given predicate.  (Like find-key, but guaranteed sequential
  139. // and accepts start: and end: rather than skip:.)
  140.  
  141. // This program makes heavy use of start: and end: keywords (in order to avoid
  142. // copying subsequences).  Find-key would have been completely unsuitable for
  143. // this unless we used <subsequence>s to refer to slices of existing
  144. // sequences, and even then the efficiency penalty would have been high.  It
  145. // therefore seemed better to simply define new routines to do "the right
  146. // thing". 
  147. define method sfind(seq :: <sequence>, pred?, 
  148.             #key start: start = 0,
  149.                  end: last, failure: fail)
  150.   block (return)
  151.     let last = if (last) min(last, size(seq)) else size(seq) end if;
  152.     for (i :: <integer> from start below last)
  153.       if (pred?(seq[i])) return(i)  end if;
  154.     finally 
  155.       fail;
  156.     end for;
  157.   end block;
  158. end method sfind;
  159.  
  160. // Like sfind, but goes backward from the end (or from before end:).
  161. define method rsfind(seq :: <sequence>, pred?,
  162.              #key start: start = 0,
  163.                   end: last, failure: fail)
  164.   block (return)  
  165.     let last = if (last) min(last, size(seq)) else size(seq) end if;
  166.     for (i from last - 1 to start by -1) 
  167.       if (pred?(seq[i])) return(i)  end if;
  168.     finally 
  169.       fail;
  170.     end for;
  171.   end block;
  172. end method rsfind;
  173.  
  174. // The notation "'!' * 5" is a good way to create a string of repeated
  175. // characters.  This variety of overloaing is becoming popular in several
  176. // modern languages (i.e. C++, Perl, and Ada).
  177. define method \*(ch :: <character>,
  178.          times :: <integer>)  => (result :: <byte-string>);
  179.   make(<byte-string>, size: times, fill: ch) 
  180. end method \*;
  181.  
  182. ////////////////////////////////////////////////////////////////////////
  183. //                 Basic HTML Utilities              //
  184. ////////////////////////////////////////////////////////////////////////
  185.  
  186. // Simply a conventient shorthand for writing to *standard-output*.
  187. define method write-string(string :: <string>)
  188.   write(string, *standard-output*);
  189. end method write-string;
  190.  
  191. // Print a line according to *margin* and *linelen*.  Add special handling for
  192. // *prefix* hack.  Streams don't automatically flush output at the ends of
  193. // lines, so we flush the output ourselves to allow the output to be viewed
  194. // interactively. 
  195. define method print-with-prefix(str :: <string>, #rest args) 
  196.   for (i from 1 to *margin* - size(prefix))
  197.     write(' ', *standard-output*);
  198.   end for;
  199.   write-string(prefix); 
  200.   apply(write-line, str, *standard-output*, args);
  201.   prefix := "" ;
  202.   force-output(*standard-output*);
  203. end method print-with-prefix;
  204.  
  205. // As mentioned above, "tag action routines" are stored in tables for easy
  206. // reference.  They are keyed by symbols corresponding to the tag (i.e.
  207. // #"text"). 
  208. define constant add-text-table :: <tag-table> = make(<tag-table>);
  209.  
  210. // The heavy duty search and replace operations in "add-text" are in the
  211. // critical path, so it is worth optimizing these by pre-computing the search
  212. // tables.  For more details, look at the "string-search" module in
  213. // "extensions". 
  214. define constant tab-to-space
  215.   = make-substring-replacer("\t", replace-with: " ");
  216. define constant convert-lt
  217.   = make-substring-replacer("<", replace-with: "<");
  218. define constant convert-gt
  219.   = make-substring-replacer(">", replace-with: ">");
  220. define constant convert-amp
  221.   = make-substring-replacer("&", replace-with: "&");
  222.  
  223. // Accumulates text within a single tag environment.  The appropriate tag
  224. // action routine is called to transform the given text.  This may be
  225. // "identity", "as-uppercase", or any other arbitrary action.
  226. // This routine also transforms "quoted characters" (such as "<" for '<')
  227. // into their ascii equivalents and crunches tabs down into spaces.
  228. define method add-text(tag :: <symbol>, text :: <strings>,
  229.                new-text :: <string>) => (result :: <strings>);
  230.   // replace-substring only works on <byte-string>s.
  231.   let new-text :: <string> =
  232.     as(<byte-string>, new-text);
  233.   let Tab-Free :: <string> =
  234.     if (Pre-Count = 0)
  235.       tab-to-space(new-text);
  236.     else
  237.       new-text;
  238.     end if;
  239.   let AMP :: <string> = convert-amp(convert-lt(convert-gt(Tab-Free)));
  240.   
  241.   let new-text = element(add-text-table, tag, default: identity)(AMP);
  242.   
  243.   if (empty?(new-text)) text else add!(text, new-text) end;
  244. end method add-text;
  245.  
  246. // Special processing is required when newlines are encountered in the input
  247. // stream.  If we are in a "<PRE>" environment, then we simply include a
  248. // newline in the output.  If we are in any other environment, we must guess
  249. // the correct number of spaces to put in based upon the punctuation of the
  250. // previous line.
  251. define method add-eol(text :: <strings>) => (result :: <strings>);
  252.   if (Pre-Count > 0) 
  253.     add!(text, "\n") 
  254.   else
  255.     let Prev-Str = last(text, default: "");
  256.     if (Prev-Str.empty?)
  257.       text;
  258.     else
  259.       let space = 
  260.     select (Prev-Str.last)
  261.       '.', ':', '!', '?' =>
  262.         "  ";
  263.       '-', ' ' =>
  264.         "";
  265.       otherwise =>
  266.         " ";
  267.     end select;
  268.       add!(text, space);
  269.     end if;
  270.   end if 
  271. end method add-eol;
  272.  
  273. // The "break-up" routines produce and print appropriate formatted text from
  274. // the accumulated data.  The action defaults to the #"text" action, which
  275. // breaks the text into lines (at word boundaries)according to the defined
  276. // margins.  "break-up" then clears the accumulated text before returning
  277. // control to the main loop.
  278. define constant break-up-table :: <tag-table> = make(<tag-table>);
  279. define method break-up(tag :: <symbol>, text :: <strings>, 
  280.                blank :: <boolean>,
  281.                want-blank :: <boolean>) => (result :: <boolean>);
  282.   let full-text = if (text.empty?) "" else apply(concatenate, text) end;
  283.   block ()
  284.     break-up-table[tag](full-text, blank, want-blank);
  285.   exception <error>
  286.     break-up-table[#"TEXT"](full-text, blank, want-blank);
  287.   cleanup
  288.     size(text) := 0;
  289.   end block;
  290. end method break-up;
  291.  
  292. // Tag close defines the appropriate action to take at the end of an
  293. // environment (i.e. when encountering "</PRE>".  This may be a null action,
  294. // or may call "break-up" to dump the accumulated text, or may perform any
  295. // other arbitrary action.
  296. define constant tag-close-table :: <tag-table> = make(<tag-table>);
  297. define method tag-close(tag :: <symbol>, close :: <symbol>,
  298.             text :: <strings>, blank :: <boolean>)
  299.     => (result :: <boolean>);
  300.   if (tag ~= close) 
  301.     signal(concatenate("Tag mismatch: <", as(<string>, tag), "> vs. </",
  302.                as(<string>, close), ">.\n"))  
  303.   end if;
  304.   block ()
  305.     tag-close-table[tag](tag, text, blank);
  306.   exception <error>
  307.     tag-close-table[#"TEXT"](tag, text, blank);
  308.   end block;
  309. end method tag-close;
  310.  
  311. // Tag start defines the appropriate action to take at the beginning of an
  312. // environment (i.e. when encountering "<PRE>".  This may be a null action,
  313. // or may call "break-up" to dump the accumulated text, or may perform any
  314. // other arbitrary action.
  315. define constant tag-start-table :: <tag-table> = make(<tag-table>);
  316. define method tag-start(New-Tag :: <symbol>, Old-Tag :: <symbol>,
  317.             Out-Text :: <strings>, Current-Text :: <string>, 
  318.             File :: <stream>, blank :: <boolean>)
  319.     => (New-Text :: <string>, blank :: <boolean>);
  320.   let fun = block ()
  321.           tag-start-table[New-Tag];
  322.         exception <error>
  323.           signal("Unknown tag type: <%=>\n", New-Tag);
  324.           tag-start-table[#"TEXT"];
  325.         end block;
  326.   fun(New-Tag, Old-Tag, Out-Text, Current-Text, File, Blank);
  327. end method tag-start;
  328.  
  329. // This routine is called at "load time" to build the tag action tables.  Note
  330. // that "reasonable" defaults are defined for all actions so that only the
  331. // "specialized" actions for any given environment need be specified.
  332. define method add-tag(tags :: <sequence>,
  333.               #key add-text: AT = identity,
  334.                    break-up: BU = break-up-table[#"TEXT"],
  335.                    tag-close: TC = tag-close-table[#"TEXT"],
  336.                    tag-start: TS = tag-start-table[#"TEXT"])
  337.   for (tag in tags)
  338.     let Tag-Symbol = as(<symbol>, tag);
  339.     add-text-table[Tag-Symbol] := AT;
  340.     break-up-table[Tag-Symbol] := BU;
  341.     tag-close-table[Tag-Symbol] := TC;
  342.     tag-start-table[Tag-Symbol] := TS;
  343.   end for;
  344. end method add-tag;
  345.  
  346. ////////////////////////////////////////////////////////////////////////
  347. //                 Main Driver Routines              //
  348. ////////////////////////////////////////////////////////////////////////
  349.  
  350. // This is the workhorse routines.  It reads in new data, searches for tags,
  351. // and dispatches the appropriate "add-text", "tag-start", and "tag-close"
  352. // routines.  It also attempts to unwind gracefully when it encounters the end
  353. // of the file, since many HTML data files fail to terminate all environments.
  354. define method process-HTML(Tag :: <symbol>, Out-Text :: <strings>, 
  355.                Current-Text :: <string>, File :: <stream>,
  356.                blank :: <boolean>)
  357.     => (Current-Text :: <string>, blank :: <boolean>);
  358.   
  359.   local method is-space(ch) ch == ' ' | ch == '\t' end method;
  360.   local method tag-end(ch) ch == ' ' | ch == '\t' | ch == '>' end method;
  361.   local method not-space(ch) ch ~= ' ' & ch ~= '\t' end method;
  362.   
  363.   block (return)
  364.     while (#t)
  365.       // keep crunching until EOF causes us to call "return"
  366.       let Start-Tag = sfind(Current-Text, curry(\==, '<'));
  367.       if (Start-Tag)
  368.     // There is a tag on this line, so we accumulate the text which
  369.     // precedes it and then invoke the appropriate tag actions.
  370.     Out-Text := add-text(Tag, Out-Text,
  371.                  subsequence(Current-Text, end: Start-Tag));
  372.     
  373.     // If a newline occurs within a tag, we must keep reading until we get
  374.     // the rest of the tag.  Whitespace is simply used as a separator, so
  375.     // we substitute a space for the newline.
  376.     let End-Tag =
  377.       for (index = sfind(Current-Text, curry(\==, '>'), start: Start-Tag)
  378.          then sfind(Current-Text, curry(\==, '>'), start: Start-Tag),
  379.            until index)
  380.         Current-Text := concatenate(Current-Text, " ", read-line(File));
  381.       finally index;
  382.       end for;
  383.     
  384.     // Find the complete tag and figure out whether it is "opening" or
  385.     // "closing" an environment.
  386.     let first = sfind(Current-Text, not-space, start: Start-Tag + 1);
  387.     let Is-Close = Current-Text[first] = '/'; 
  388.     if (Is-Close)
  389.       first := sfind(Current-Text, not-space, start: first + 1)
  390.     end if; 
  391.     let New-Tag =
  392.       as(<symbol>, copy-sequence(Current-Text, start: first, 
  393.                      end: sfind(Current-Text, tag-end,
  394.                         start: first)));
  395.     // Call the appropriate action for the tag.  This may invoke
  396.     // a recursive call to "process-HTML" for start tags and will exit
  397.     // this recusive call for closing tags.
  398.     Current-Text := copy-sequence(Current-Text, start: End-Tag + 1);
  399.     if (Is-Close)
  400.       return(Current-Text, tag-close(Tag, New-Tag, Out-Text, blank));
  401.     else 
  402.       let (New-Text, NewBlank) = 
  403.         tag-start(New-Tag, Tag, Out-Text, Current-Text, File, blank);
  404.       Current-Text := New-Text;
  405.       blank := NewBlank; 
  406.     end if;
  407.       else
  408.     // Process newlines.  We ignore indentation in the next line unless we
  409.     // are inside a "<PRE>" environment.
  410.     Out-Text := add-eol(add-text(Tag, Out-Text, Current-Text));
  411.     let (New-Text, eof) = read-line(File);
  412.     let First-Real = if (Pre-Count = 0)
  413.                sfind(New-Text, not-space, failure: 0);
  414.              else 0
  415.              end if;
  416.     Current-Text := if (First-Real > 0)
  417.               copy-sequence(New-Text, start: First-Real);
  418.             else
  419.               New-Text;
  420.             end if;
  421.       end if;
  422.     end while;
  423.   exception <end-of-file>
  424.     // End of file processing.  Dump accumulated text and then exit.
  425.     let blank = break-up(Tag, Out-Text, blank, #f);
  426.     values("", blank);
  427.   end block 
  428. end method process-HTML;
  429.  
  430. // specialized routines to open various sourts of streams and invoke
  431. // "process-HTML".
  432. define method html2text(fd :: <stream>) => ();
  433.   process-HTML(#"TEXT", make(<strings>), "", fd, #t);
  434.   force-output(*standard-output*);
  435. end method html2text;
  436.  
  437. define method html2text(file :: <string>) => ();
  438.   let stream = make(<file-stream>, name: file);
  439.   html2text(stream);
  440. end method html2text;
  441.  
  442. define method html2text(file == #t) => ();
  443.   html2text(make(<fd-stream>, fd: 0));
  444. end method html2text;
  445.  
  446. // Trivial main program -- just invokes "html2text" which in turn invokes
  447. // "process-HTML".  Note that we had to import the generic function "main"
  448. // from module "extensions" in library "dylan".  This interface is Mindy
  449. // specific. 
  450. define method main (argv0, #rest args) => ();
  451.   if (empty?(args))
  452.     html2text(#t);
  453.   else
  454.     map(html2text, args);
  455.   end if;
  456. end method main;
  457.  
  458. ////////////////////////////////////////////////////////////////////////
  459. //            Specific Environment Routines              //
  460. ////////////////////////////////////////////////////////////////////////
  461.  
  462. // The anonymous methods here implement the appropriate tag actions for all of
  463. // the tags currently supported.  Some are quite straightforward, while others
  464. // may require a twisted mind to "properly appreciate" them.  This
  465. // organization does, at least, allow the processing of most tags to be
  466. // isolated so that you needn't grok all the code at once.
  467.  
  468. add-tag(#["TEXT"],           // Default environment
  469.     // Performs a "paragraph break" and recursively processes the new
  470.     // environment
  471.     tag-start: method (New-Tag :: <symbol>, Old-Tag :: <symbol>, 
  472.                Out-Text :: <strings>, Current-Text :: <string>,
  473.                File :: <stream>, blank :: <boolean>)
  474.                => (result :: <string>, blank :: <boolean>);
  475.              let blank = break-up(Old-Tag, Out-Text, blank, #t);
  476.              process-HTML(New-Tag, Out-Text, Current-Text,
  477.                   File, blank);
  478.            end method,
  479.     // Performs a "paragraph break" and returns to the enclosing
  480.     // environment
  481.     tag-close: method (tag :: <symbol>, text :: <strings>,
  482.                blank :: <boolean>) => (result :: <boolean>);
  483.              break-up(tag, text, blank, #t);
  484.            end method,
  485.     // Breaks "text" into lines according to *margin* and *linelen*.
  486.     // Parameters blank and want-blank say whether there is a blank line
  487.     // before the current text and whether there should be one after the
  488.     // current text.  The return value tells whether a blank line was
  489.     // printed.
  490.     break-up: method (text :: <string>, blank :: <boolean>, 
  491.               want-blank :: <boolean>)  => (result :: <boolean>);
  492.             let first = sfind(text, curry(\~=, ' ')); 
  493.             if (~first) 
  494.               if (want-blank & ~blank) write-string("\n")  end if;
  495.               blank | want-blank 
  496.             else
  497.               let Text-Size = size(text);
  498.               let Find-Break = 
  499.             method (first, last)
  500.               if (last >= Text-Size)
  501.                 Text-Size;
  502.               else 
  503.                 let find = rsfind(text, curry(\=, ' '),
  504.                           start: first, end: last); 
  505.                 if (find)   
  506.                   rsfind(text, curry(\~=, ' '), 
  507.                      start: first, end: find) + 1 
  508.                 else 
  509.                   sfind(text, curry(\=, ' '), start: first)
  510.                 | size(text)
  511.                 end if
  512.               end if
  513.             end method; 
  514.               while (first)
  515.             let last = Find-Break(first,
  516.                           first + *linelen* - *margin*);
  517.             print-with-prefix(text, start: first, end: last); 
  518.             first := sfind(text, curry(\~=, ' '), start: last + 1)
  519.               end while; 
  520.               if (want-blank) write-string("\n")  end if; 
  521.               want-blank 
  522.             end if 
  523.           end method);
  524.  
  525. // This tag action is used for many different tags -- it simply invokes
  526. // "process-HTML" recursively without doing anything special to the
  527. // accumulated text.  This is handy for "lightweight" enviromentents like
  528. // "<I>". 
  529. define constant tag-start-recurse =
  530.   method (New-Tag :: <symbol>, Old-Tag :: <symbol>, 
  531.       Out-Text :: <strings>, Current-Text :: <string>, 
  532.       File :: <stream>, blank :: <boolean>)
  533.       => (result :: <string>, blank :: <boolean>);
  534.     process-HTML(New-Tag, Out-Text, Current-Text, File, blank);
  535.   end method;
  536.  
  537. // This tag action is a logical partner for "tag-start-recurse".  It simply
  538. // exits so that control will return to an inclosing "process-HTML" call
  539. // without distrubing the accumulated text.
  540. define constant tag-close-nothing =
  541.   method (tag :: <symbol>, Out-Text :: <strings>, blank :: <boolean>)
  542.     blank;
  543.   end method;
  544.  
  545. // Specialized "add-text" methods provide EMPHASIZED versions of "<B>" or
  546. // "<I>" style environments.
  547. add-tag(#["I", "EM", "CITE", "VAR", "DFN"],
  548.     add-text: method(text :: <string>) => (result :: <string>);
  549.               if (*Icap*) as-uppercase(text) else text end
  550.           end method,
  551.     tag-start: tag-start-recurse,
  552.     tag-close: tag-close-nothing);
  553.  
  554. add-tag(#["B", "STRONG"],
  555.     add-text: method(text :: <string>) => (result :: <string>);
  556.               if (*Bcap*) as-uppercase(text) else text end
  557.           end method,
  558.     tag-start: tag-start-recurse,
  559.     tag-close: tag-close-nothing);
  560.  
  561. // Anchors do nothing at all.
  562. add-tag(#["A", "HEAD", "BODY", "UNKNOWN", "TT", "CODE", "SAMP", "KBD"],
  563.     tag-start: tag-start-recurse,
  564.     tag-close: tag-close-nothing);
  565.  
  566. // Titles are eliminated entirely -- add-text simply "adds" an empty string.
  567. add-tag(#["TITLE"], 
  568.     add-text: method(text :: <string>) => (res :: <string>); "" end method,
  569.     tag-start: tag-start-recurse,
  570.     tag-close: tag-close-nothing);
  571.  
  572. // For un-bracketed environments like "<P>", "<BR>", etc. we must make sure
  573. // "tag-start" does not start a recursive call to "process-HTML".  We may or
  574. // may not want to dump accumulated text.
  575. add-tag(#["!"],
  576.     tag-start: method (New-Tag :: <symbol>, Old-Tag :: <symbol>, 
  577.                Out-Text :: <strings>, Current-Text :: <string>,
  578.                File :: <stream>, blank :: <boolean>)
  579.                => (result :: <string>, blank :: <boolean>);
  580.              values(Current-Text, blank);
  581.            end method);
  582.  
  583. add-tag(#["P"],
  584.     tag-start: method (New-Tag :: <symbol>, Old-Tag :: <symbol>, 
  585.                Out-Text :: <strings>, Current-Text :: <string>,
  586.                File :: <stream>, blank :: <boolean>)
  587.                => (result :: <string>, blank :: <boolean>);
  588.              values(Current-Text,
  589.                 break-up(Old-Tag, Out-Text, blank, #t));
  590.            end method);
  591.  
  592. add-tag(#["BR"], 
  593.     tag-start: method (New-Tag :: <symbol>, Old-Tag :: <symbol>, 
  594.                Out-Text :: <strings>, Current-Text :: <string>,
  595.                File :: <stream>, blank :: <boolean>)
  596.                => (result :: <string>, blank :: <boolean>);
  597.              if (Pre-Count > 0)
  598.                add-eol(Out-Text);
  599.                values(Current-Text, blank);
  600.              else
  601.                values(Current-Text,
  602.                   break-up(Old-Tag, Out-Text, blank, #f));
  603.              end if;
  604.            end method);
  605.  
  606. add-tag(#["HR"],
  607.     tag-start: method (New-Tag :: <symbol>, Old-Tag :: <symbol>,
  608.                Out-Text :: <strings>, Current-Text :: <string>,
  609.                File :: <stream>, blank :: <boolean>)
  610.                => (result :: <string>, blank :: <boolean>);
  611.              break-up(Old-Tag, Out-Text, blank, #t);
  612.              write-line(concatenate('-' * *linelen*, "\n"),
  613.                 *standard-output*);
  614.              values(Current-Text, #t);
  615.            end method);
  616.  
  617. add-tag(#["IMG"],
  618.     tag-start: method (New-Tag :: <symbol>, Old-Tag :: <symbol>,
  619.                Out-Text :: <strings>, Current-Text :: <string>,
  620.                File :: <stream>, blank :: <boolean>)
  621.                => (result :: <string>, blank :: <boolean>);
  622.              break-up(Old-Tag, Out-Text, blank, #t);
  623.              write-line(concatenate(' ' * *margin* + 4,
  624.                         "*** INLINE IMAGE IGNORED ***\n"),
  625.                 *standard-output*);
  626.              values(Current-Text, #t);
  627.            end method);
  628.  
  629. // Preformatted text is tricky.  First we dump accumulated text.  Then we
  630. // increment the global variable "Pre-Count" which enables magic behavior in
  631. // several standard routines.  Finally, when the environment is closed, we
  632. // split the output around the newlines and do line-by-line output so that the
  633. // left margin will be observed.
  634. add-tag(#["PRE"],
  635.     break-up: method (text :: <string>, blank :: <boolean>,
  636.               want-blank :: <boolean>) => (result :: <boolean>);
  637.             unless(blank) write('\n', *standard-output*); end;
  638.             let first = sfind(text, curry(\~=, '\n'));
  639.             let last = rsfind(text,
  640.                       complement(rcurry(member?, "\n ")));
  641.             if (last)
  642.               while (first < last)
  643.             let endline = sfind(text, curry(\=, '\n'),
  644.                         start: first, failure: last + 1);
  645.             print-with-prefix(text, start: first, end: endline);
  646.             first := endline + 1;
  647.               end while;
  648.             end if;
  649.             write-string("\n");
  650.             #t
  651.           end method,
  652.     tag-start: method (New-Tag :: <symbol>, Old-Tag :: <symbol>,
  653.                Out-Text :: <strings>, Current-Text :: <string>,
  654.                File :: <stream>, blank :: <boolean>)
  655.                => (result :: <string>, blank :: <boolean>);
  656.              let blank = break-up(Old-Tag, Out-Text, blank, #t);
  657.              block ()
  658.                Pre-Count := Pre-Count + 1;
  659.                process-HTML(New-Tag, Out-Text, Current-Text,
  660.                     File, blank);
  661.              cleanup
  662.                Pre-Count := Pre-Count - 1;
  663.              end block;
  664.            end method);
  665.  
  666. // Since the following methods add nested indentation levels, we create a
  667. // stack for the margins.  A "document state" record might be cleaner, but is
  668. // probably overkill for this particular application.
  669. define constant margins :: <Deque> = make(<Deque>);
  670.  
  671. add-tag(#["UL", "OL", "MENU", "DL", "BLOCKQUOTE"],
  672.     tag-start: method (New-Tag :: <symbol>, Old-Tag :: <symbol>,
  673.                Out-Text :: <strings>, Current-Text :: <string>,
  674.                File :: <stream>, blank :: <boolean>)
  675.                => (result :: <string>, blank :: <boolean>);
  676.              break-up(Old-Tag, Out-Text, blank, #t);
  677.              let OldCounter = counter;
  678.              block ()
  679.                push(margins, *margin*);
  680.                *margin* := *margin* + 4;
  681.                counter := 0;
  682.                process-HTML(New-Tag, Out-Text, Current-Text,
  683.                     File, blank);
  684.              cleanup
  685.                *margin* := pop(margins);
  686.                counter := OldCounter;
  687.              end block;
  688.            end method);
  689.  
  690. // The "<LI>" tag causes bullets or numbers to be printed before the
  691. // immediately following text.  We use a global "prefix" variable to magically
  692. // change the behavior of the next call to "print-with-prefix".  The precise
  693. // choice of prefix depends upon the enclosing environment.
  694. add-tag(#["LI"],
  695.     tag-start: method (New-Tag :: <symbol>, Old-Tag :: <symbol>,
  696.                Out-Text :: <strings>, Current-Text :: <string>,
  697.                File :: <stream>, blank :: <boolean>)
  698.                => (result :: <string>, blank :: <boolean>);
  699.              let blank = break-up(Old-Tag, Out-Text, blank, #f);
  700.              if (Old-Tag = #"OL")
  701.                counter := counter + 1;
  702.                prefix := copy-sequence("0. ");
  703.                prefix[0] := as(<character>,
  704.                        counter + as(<integer>, '0'));
  705.              else
  706.                prefix := "* ";
  707.              end if;
  708.              values(Current-Text, blank);
  709.            end method);
  710.  
  711. // In "<DL>" environments, we must simply switch the left margin back and
  712. // forth between "unindented" and "indented" depending on whether we are
  713. // currently processing a "term" or a "definition".
  714. add-tag(#["DT"],
  715.     tag-start: method (New-Tag :: <symbol>, Old-Tag :: <symbol>,
  716.                Out-Text :: <strings>, Current-Text :: <string>,
  717.                File :: <stream>, blank :: <boolean>)
  718.                => (result :: <string>, blank :: <boolean>);
  719.              let blank = break-up(Old-Tag, Out-Text, blank, #f);
  720.              *margin* := first(margins);
  721.              values(Current-Text, blank);
  722.            end method);
  723.  
  724. add-tag(#["DD"],
  725.     tag-start: method (New-Tag :: <symbol>, Old-Tag :: <symbol>,
  726.                Out-Text :: <strings>, Current-Text :: <string>,
  727.                File :: <stream>, blank :: <boolean>)
  728.                => (result :: <string>, blank :: <boolean>);
  729.              let blank = break-up(Old-Tag, Out-Text, blank, #f);
  730.              *margin* := first(margins) + 4;
  731.              values(Current-Text, blank);
  732.            end method);
  733.  
  734. // Headers may centered and/or underlined and ignore margins.  They must still
  735. // be broken up into lines, although we use a shorter line-length.
  736. add-tag(#["H1"],
  737.     break-up: method (text :: <string>, blank :: <boolean>,
  738.               want-blank :: <boolean>)  => (result :: <boolean>);
  739.             unless(blank) write('\n', *standard-output*); end;
  740.             let first = sfind(text, curry(\~=, ' ')); 
  741.             let Text-Size = size(text);
  742.             let Find-Break = 
  743.               method (first, last)
  744.             if (last >= Text-Size)
  745.               Text-Size;
  746.             else 
  747.               let find = rsfind(text, curry(\=, ' '),
  748.                         start: first, end: last); 
  749.               if (find)   
  750.                 rsfind(text, curry(\~=, ' '), 
  751.                    start: first, end: find) + 1 
  752.               else 
  753.                 sfind(text, curry(\=, ' '), start: first)
  754.                   | size(text)
  755.               end if
  756.             end if
  757.               end method; 
  758.             let Max-Length = 0;
  759.             while (first)
  760.               let last = Find-Break(first, first + *linelen* - 20);
  761.               Max-Length := max(Max-Length, last - first);
  762.               write-string(' ' * truncate/(*linelen* + first - last,
  763.                            2));
  764.               write-line(text, *standard-output*,
  765.                  start: first, end: last); 
  766.               first := sfind(text, curry(\~=, ' '), start: last + 1)
  767.             end while;
  768.             if (*H1under*)
  769.               write-string(' ' * truncate/(*linelen* - Max-Length, 2));
  770.               write-line('=' * Max-Length, *standard-output*); 
  771.             end if;
  772.             if (want-blank) write-string("\n")  end if; 
  773.             want-blank 
  774.           end method);
  775.  
  776. add-tag(#["H2"],
  777.     break-up: method (text :: <string>, blank :: <boolean>,
  778.               want-blank :: <boolean>)  => (result :: <boolean>);
  779.             unless(blank) write('\n', *standard-output*); end;
  780.             let first = sfind(text, curry(\~=, ' ')); 
  781.             let Text-Size = size(text);
  782.             let Find-Break = 
  783.               method (first, last)
  784.             if (last >= Text-Size)
  785.               Text-Size;
  786.             else 
  787.               let find = rsfind(text, curry(\=, ' '),
  788.                         start: first, end: last); 
  789.               if (find)   
  790.                 rsfind(text, curry(\~=, ' '), 
  791.                    start: first, end: find) + 1 
  792.               else 
  793.                 sfind(text, curry(\=, ' '), start: first)
  794.                   | size(text)
  795.               end if
  796.             end if
  797.               end method; 
  798.             let Max-Length = 0;
  799.             while (first)
  800.               let last = Find-Break(first, first + *linelen* - 20);
  801.               Max-Length := max(Max-Length, last - first);
  802.               write-line(text, *standard-output*,
  803.                  start: first, end: last); 
  804.               first := sfind(text, curry(\~=, ' '), start: last + 1)
  805.             end while;
  806.             if (*H2under*)
  807.               write-line('-' * Max-Length, *standard-output*);
  808.               #f;
  809.             else
  810.               write('\n', *standard-output*);
  811.               #t
  812.             end if;
  813.           end method);
  814.  
  815. add-tag(#["H3", "H4", "H5", "H6"],
  816.     break-up: method (text :: <string>, blank :: <boolean>,
  817.               want-blank :: <boolean>)  => (result :: <boolean>);
  818.             unless(blank) write('\n', *standard-output*); end;
  819.             block ()
  820.               push(margins, *margin*);
  821.               *margin* := 0;
  822.               add-text-table[#"TEXT"](text, #t, want-blank);
  823.             cleanup
  824.               *margin* := pop(margins);
  825.             end;
  826.           end method);
  827.